R/mixture functions.R

In Atan1988/FlexFit: Fits Severity distributions for Insurance data

#' @title cdf defintion of mixture dstributions
#' @param ws is the weights of various distributions
#' @param distrs is the distributions to be mixed
#' @param pars_list is the list of parameters for the distributions
#' @param parnamess is the list of parameters names for the distributions, if NULL the match would be done by order
pmixture <- function(q, ws, distrs, pars_list, parnames=NULL) {
   if (length(distrs) == 1)  distrs <- rep(distrs, length(ws))

   if (purrr::is_null(parnames))
     pars_list_named <- mapply(assign_to_pars, distr = distrs, pars = pars_list, SIMPLIFY = F)

   get_ps <- function(distr, pars_named) {
     do.call(get(paste0("p", distr)), args = append(list(q = q), lapply(pars_named, identity)))
   }

   ps <- unlist(mapply(get_ps, distr = distrs, pars_named = pars_list_named, SIMPLIFY = F))

   as.vector((ws %*% ps)/ sum(ws))
}

#' @title pdf defintion of mixture dstributions
#' @param ws is the weights of various distributions
#' @param distrs is the distributions to be mixed
#' @param pars_list is the list of parameters for the distributions
#' @param parnamess is the list of parameters names for the distributions, if NULL the match would be done by order
dmixture <- function(x, ws, distrs, pars_list, parnames=NULL) {
  if (length(distrs) == 1)  distrs <- rep(distrs, length(ws))

  if (purrr::is_null(parnames))
    pars_list_named <- mapply(assign_to_pars, distr = distrs, pars = pars_list, SIMPLIFY = F)

  get_ds <- function(distr, pars_named) {
    do.call(get(paste0("d", distr)), args = append(list(x = x), lapply(pars_named, identity)))
  }

  ds <- unlist(mapply(get_ds, distr = distrs, pars_named = pars_list_named, SIMPLIFY = F))

  as.vector((ws %*% ds)/ sum(ws))
}

assign_to_pars <- function(distr, pars) {
   distr_args <- as.list(args(get(paste0("p", distr))))
   names(pars) <- sapply(2:(length(pars) + 1), function(x) names(distr_args)[x])
   return(pars)
}

#' @title inverse cdf defintion of mixture dstributions
#' numeric q functions for distributions that don't have a closed form q function, often mixed distributions
#' @param p the percentile
#' @param FUN the name of the target distribution
#' @export
qfunc <- function(p, FUN = "mixlnorm", ...) {
  add_args <- list(...)

  pFUN_f <- function(q, distr = FUN, ... ) {
    do.call(ptrunc, args = append(list(x = q, FUN= distr), add_args ))
  }

  if (existsFunction(paste0("q", FUN))){
    return(do.call(qtrunc, args = append(list(x = p, FUN = FUN), add_args)) )
  } else {
    fun <- function(x, p) do.call(pFUN_f, args = append(list(q = x), add_args)) - p
    cat(paste0("q", FUN), " doesn't exist, quantiles are solved numerically and can be time consuming")
    return(unlist(lapply(p, function(y) uniroot(fun, c(0, 5e9), p = y)$root)))
  }
}